home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / aijournl / 1989_05 / aibina.pas next >
Pascal/Delphi Source File  |  1988-09-18  |  16KB  |  630 lines
  1. {$R-}    {Range checking off}
  2. {$B+}    {Boolean complete evaluation on}
  3. {$S+}    {Stack checking on}
  4. {$I+}    {I/O checking on}
  5.  
  6. Unit aiBINA;
  7.  
  8. Interface
  9.  
  10. Uses
  11.      DOS,      CRT, aiglob,
  12.      GLOBUNIT, JWINUNIT,
  13.      Grafunit;
  14.  
  15. Type
  16.    Mtype = array[1..6] of string;
  17.  
  18. Var
  19.    Menux,
  20.    Menu1,
  21.    Menu2    : Mtype;
  22.  
  23.  
  24. procedure HistogramStretch(Var hx,lx : byte);
  25. procedure HistogramEqual;
  26. Procedure Digitlocate(var xdig,ydig,butdig,errdig : integer);
  27. Procedure SetUpMenu;
  28. Function ChooseMenu(MenuData,x,y:byte):byte;
  29. Procedure DisplayMenu(DoAll:boolean);
  30. Procedure SetSubMenu1;
  31. Procedure SetSubMenu2;
  32. Procedure DisplaySubMenu1(Doall:boolean);
  33. Procedure DisplaySubMenu2(DoAll:boolean);
  34. Procedure ZapMwindow;
  35. Function AskWindow:boolean;
  36. function Askwindow2:boolean;
  37. Procedure Fixit;
  38. Procedure MakeAnotherWindow;
  39. Procedure Message1;
  40. procedure Message2;
  41. procedure Message3;
  42. Procedure Message4;
  43. Procedure Message6;
  44. Procedure Message7;
  45. Procedure Message8;
  46. {===========================================================================}
  47.  
  48. Implementation
  49.  
  50. {$F+}
  51.   procedure DigitLocate(var XDig,YDig,ButDig,ErrDig : integer);
  52. {===============================================================}
  53.       var
  54.     M1,M2,M3,M4 :       Integer;
  55.  
  56.     procedure Mouse(var M1,M2,M3,M4 : Integer);
  57.  
  58.       begin
  59.     with Reg do begin
  60.       AX := M1;           { Set up ax,bx,cx,dx for interrupt }
  61.       BX := M2;
  62.       CX := M3;
  63.       DX := M4;
  64.     end;
  65.     Intr(51,Reg);           { Trip interrupt 51 }
  66.     with Reg do begin
  67.       M1 := AX;
  68.       M2 := BX;
  69.       M3 := CX;
  70.       M4 := DX
  71.     end
  72.       end; { of procedure Mouse }
  73.  
  74.   begin { procedure DigitLocate }
  75.     if keypressed then;
  76.     M1 := 3;            { Get Mouse Button Status }
  77.       Mouse(M1,M2,M3,M4);
  78.       ButDig := M2;
  79.       case ButDig of
  80.         0 :  ButDig := 0;
  81.         1 :  ButDig := 1;
  82.         2 :  ButDig := 3;
  83.         3 :  ButDig := 3;
  84.         4 :  ButDig := 2;
  85.         5 :  ButDig := 3;
  86.         6 :  ButDig := 3;
  87.         7 :  ButDig := 3;
  88.       end;
  89.  
  90.     M1 := 11;            { Read Mouse Motion Counters }
  91.       {Mouse(M1,M2,M3,M4);}
  92.       if M3 > 1000 then M3 := M3 - 65536;
  93.        XDig := XDig + M3;
  94.     if XDig < 0 then XDig := 0;
  95.     if XDig > 511 then XDig := 511;
  96.       if M4 > 1000 then M4 := M4 - 65536;
  97.        YDig := YDig + M4;
  98.     if YDig < 0 then YDig := 0;
  99.     if YDig > 511 then YDig := 511;
  100.       ErrDig := 0;
  101. (*
  102.     if (CorrectforShading = TRUE) then
  103.       begin
  104.         CorrectforShading := FALSE;
  105.         NewShadingCorrect;
  106.       end;
  107. *)
  108.   end; { of procedure DigitLocate }
  109. {$F-}
  110.  
  111.  
  112.   procedure SelectLUTMode(i : integer);
  113. { ++++++++++++++++++++++++++++++++++++++++++++++++++ }
  114.     var Temp : byte;
  115.     begin
  116.  
  117. {$IFDEF PCVISION}
  118.       Temp := Port[ConLow] and $F9;                    {1111 1001}
  119.       case i of
  120.         0 : Port[ConLow] := Temp + 6;           { input  : ---- -11- }
  121.         1 : Port[ConLow] := Temp;               { red    : ---- -00- }
  122.         2 : Port[ConLow] := Temp + 2;           { green  : ---- -01- }
  123.         3 : Port[ConLow] := Temp + 4;           { blue   : ---- -10- }
  124.       end;
  125. {$ENDIF}
  126.  
  127. {$IFDEF PCPLUS}
  128.       Temp := Port[LUTControl] and $FC;                   {1111 1100}
  129.       case i of
  130.         0 : Port[LUTControl] := Temp + 3;       { input  : ---- --11 }
  131.         1 : Port[LUTControl] := Temp;           { red    : ---- --00 }
  132.         2 : Port[LUTControl] := Temp + 1;       { green  : ---- --01 }
  133.         3 : Port[LUTControl] := Temp + 2;       { blue   : ---- --10 }
  134.       end;
  135. {$ENDIF}
  136.     end;
  137.  
  138.   procedure SelectInpLUT(i : integer);
  139. { ++++++++++++++++++++++++++++++++++++++++++++++++++ }
  140.     var Temp : byte;
  141.     begin
  142.  
  143. {$IFDEF PCVISION}
  144.       Temp := Port[ConLow] and $3F;                   {0011 1111}
  145.       case i of
  146.         0 : Port[ConLow] := Temp;                    {0:  00-- ---- }
  147.         1 : Port[ConLow] := Temp + $40;              {1:  01-- ---- }
  148.         2 : Port[ConLow] := Temp + $80;              {2:  10-- ---- }
  149.         3 : Port[ConLow] := Temp + $C0;              {3:  11-- ---- }
  150.       end;
  151. {$ENDIF}
  152.  
  153. {$IFDEF PCPLUS}
  154.       Temp := Port[LUTControl] and $E3;                       {1110 0011}
  155.       case i of
  156.         0 : Port[LUTControl] := Temp;                    {0:  ---0 00-- }
  157.         1 : Port[LUTControl] := Temp + $04;              {1:  ---0 01-- }
  158.         2 : Port[LUTControl] := Temp + $08;              {2:  ---0 10-- }
  159.         3 : Port[LUTControl] := Temp + $0C;              {3:  ---0 11-- }
  160.         4 : Port[LUTControl] := Temp + $10;              {4:  ---1 00-- }
  161.         5 : Port[LUTControl] := Temp + $14;              {5:  ---1 01-- }
  162.         6 : Port[LUTControl] := Temp + $18;              {6:  ---1 10-- }
  163.         7 : Port[LUTControl] := Temp + $1C;              {7:  ---1 11-- }
  164.       end;
  165. {$ENDIF}
  166.     end;
  167.  
  168.   procedure SelectOutLUT(i : integer);
  169. { ++++++++++++++++++++++++++++++++++++++++++++++++++ }
  170.     var Temp : byte;
  171.     begin
  172.  
  173. {$IFDEF PCVISION}
  174.       Temp := Port[ConHigh] and $9F;                   {1001 1111}
  175.       case i of
  176.         0 : Port[ConHigh] := Temp;                    {0:  -00- ---- }
  177.         1 : Port[ConHigh] := Temp + $20;              {1:  -01- ---- }
  178.         2 : Port[ConHigh] := Temp + $40;              {2:  -10- ---- }
  179.         3 : Port[ConHigh] := Temp + $60;              {3:  -11- ---- }
  180.       end;
  181. {$ENDIF}
  182.  
  183. {$IFDEF PCPLUS}
  184.       Temp := Port[LUTControl] and $1F;                       {0001 1111}
  185.       case i of
  186.         0 : Port[LUTControl] := Temp;                    {0:  000- ---- }
  187.         1 : Port[LUTControl] := Temp + $20;              {1:  001- ---- }
  188.         2 : Port[LUTControl] := Temp + $40;              {2:  010- ---- }
  189.         3 : Port[LUTControl] := Temp + $60;              {3:  011- ---- }
  190.         4 : Port[LUTControl] := Temp + $80;              {4:  100- ---- }
  191.         5 : Port[LUTControl] := Temp + $A0;              {5:  101- ---- }
  192.         6 : Port[LUTControl] := Temp + $C0;              {6:  110- ---- }
  193.         7 : Port[LUTControl] := Temp + $E0;              {7:  111- ---- }
  194.       end;
  195. {$ENDIF}
  196.  
  197.    end;
  198.  
  199.  
  200. Procedure StretchLUT;
  201. {++++++++++++++++++++++}
  202. Var M      : real;
  203.     B,
  204.     ValueA : integer;
  205.  
  206. Begin
  207.  
  208.     b := StretchLow;                              { intercept }
  209.     if StretchHigh = StretchLow then StretchHigh := StretchHigh + 1;
  210.     m := 255 / (StretchHigh - StretchLow);          { slope }
  211.  
  212.     SelectOutLUT(1);                  { LUT 1 = for overlay }
  213.     for i := 1 to 3 do
  214.       begin
  215.         SelectLUTMode(i);       { select R, G, and B output LUTs }
  216.         for ValueA := 0 to 255 do
  217.           begin
  218.             Port[LUTAddress] := ValueA;
  219.             if ((ValueA and 1) = 1) then   {if Bit 0 = on}
  220.               case i of
  221.                 1 : Port[LUTData] := 255;
  222.                 2 : Port[LUTData] := 0;
  223.                 3 : Port[LUTData] := 0;    {draw overlay in red}
  224.               end {case}
  225.             else if (ValueA <= StretchLow) then Port[LUTData] := 0
  226.               else if (ValueA >= StretchHigh) then Port[LUTData] := 254
  227.                 else Port[LUTData] := (round(m*(ValueA - b)) and $FE);
  228.           end;
  229.       end;
  230.  
  231. end;{end procedure stretchlut}
  232.  
  233.  
  234.  
  235.  Procedure FindLowHigh(VAR LowVal,HighVal : integer);
  236. {+++++++++++++++++++++++++++++++++++++++++++++++++++++}
  237.  Var Offset     : word;
  238.      x,
  239.      y          : word;
  240.      Temp       : integer;
  241.      Block,
  242.      Blocktemp  : word;
  243.      i : byte;
  244.      done : boolean;
  245.  
  246. Begin
  247.  
  248.   for Temp := 0 to 255 do
  249.     GLHistogram[Temp] := 0;
  250.  
  251.   Lowval := 255;
  252.   Highval := 0;
  253.  
  254.   For Block := 0 to 3 do
  255.  
  256.   begin
  257.  
  258. {$IFDEF PCPLUS}
  259.     Blocktemp := Port[Control] and $1F;
  260.     Case Block of
  261.     0 : Port[Control] := blocktemp;
  262.     1 : Port[Control] := blocktemp + $20;
  263.     2 : Port[Control] := blocktemp + $40;
  264.     3 : Port[Control] := blocktemp + $60;
  265.     end;
  266.  
  267.     For Y := 0 to 31 do
  268.      For X := 15 to 127 do
  269.      Begin
  270.      Offset := 2048*y + (4*x);
  271. {$ENDIF}
  272. {$IFDEF PCVISION}
  273.     Port[FBB0] := Block;
  274.  
  275.     For Y := 0 to 63 do
  276.      For X := 15 to 63 do
  277.      Begin
  278.      Offset := 1024*y + (4*x);
  279. {$ENDIF}
  280.  
  281.          Temp := Mem[MemBase : Offset];
  282. {$IFDEF PCPLUS}
  283.          If  NOT((block = 3) and (offset >= 49152)) then
  284. {$ENDIF}
  285. {$IFDEF PCVISION}
  286.          If NOT(((Block = 2) or (Block = 3)) and (Y > 223)) then
  287. {$ENDIF}
  288.          begin
  289.            GLHistogram[Temp] := GLHistogram[Temp] + 1;
  290.  
  291.          end;
  292.  
  293.    end;{loop}
  294.  
  295.  end;{block loop}
  296.              done := FALSE;
  297.              i := 1;
  298.              repeat
  299.                if GLHistogram[i] > 40 then
  300.                begin
  301.                  done := TRUE;
  302.                  LowVal := i;
  303.                end
  304.                else if i = 255 then
  305.                  done := TRUE;
  306.                i := i + 1;
  307.              until done;
  308.              done := FALSE;
  309.              i := 255;
  310.              repeat
  311.                if GLHistogram[i] > 40 then
  312.                begin
  313.                  done := TRUE;
  314.                  HighVal := i;
  315.                end
  316.                else if i = 0 then
  317.                  done := TRUE;
  318.                i := i - 1;
  319.              until done;
  320.  
  321. end;{end procedure}
  322.  
  323.  
  324. Procedure SetUpMenu;
  325. begin
  326.   SetNoCursor;
  327.   menux[1] := 'Pixel Finder            ';
  328.   menux[2] := 'Set Up Parameters       ';
  329.   menux[3] := 'Auto Scan               ';
  330.   menux[4] := 'Manual Fill             ';
  331.   menux[5] := 'Manual Erase            ';
  332.   menux[6] := 'Exit                    ';
  333. end;
  334.  
  335. Procedure SetSubMenu1;
  336. begin
  337.   Menu1[1] := 'Store Shading            ';
  338.   Menu1[2] := 'Shading Correct          ';
  339.   Menu1[3] := 'Set Critical Data        ';
  340.   Menu1[4] := 'Histogram Stretch        ';
  341.   Menu1[5] := 'World Interface          ';
  342.   Menu1[6] := 'Exit                     ';
  343. end;
  344.  
  345. Procedure SetSubMenu2;
  346. begin
  347.   Menu2[1] := 'Display Data             ';
  348.   Menu2[2] := 'Learn Mode               ';
  349.   Menu2[3] := 'Initialize               ';
  350.   Menu2[4] := 'Report to Printer        ';
  351.   Menu2[5] := 'Set Scan Box             ';
  352.   Menu2[6] := 'Exit                     ';
  353. end;
  354.  
  355. Procedure DisplayMenu(DoAll:boolean);
  356. Var i : byte;
  357. begin
  358.   If Doall then
  359.   begin
  360.     Makewindow2;
  361.   end;
  362.   For i := 1 to 6 do
  363.     Writetopage(menux[i],attr(lightred,blue),0,8+i,34);
  364. end;
  365.  
  366. Procedure DisplaySubMenu1(DoAll:boolean);
  367. Var i : byte;
  368. begin
  369.   If DoAll then
  370.     Makewindow1;
  371.   For i := 1 to 6 do
  372.     Writetopage(menu1[i],attr(lightred,blue),0,7+i,30);
  373. end;
  374.  
  375. Procedure MakeAnotherWindow;
  376. begin
  377.     scanpage;
  378.     createwindow(11,30,8,40,blue,cyan,lightgreen,black);
  379.   end;
  380.  
  381. Procedure DisplaySubMenu2(DoAll:boolean);
  382. Var i : byte;
  383. begin
  384.   If doAll then
  385.      MakeAnotherwindow;
  386.  
  387.   If LearnMode then
  388.     Menu2[2] := 'Learn Mode ON            '
  389.   else
  390.     Menu2[2] := 'Learn Mode OFF           ';
  391.   For i := 1 to 6 do
  392.     writetoPage(menu2[i],attr(blue,cyan),0,10+i,40);
  393. end;
  394.  
  395. Procedure Message1;
  396. begin
  397.   Explode('                              ',14,36,blue,cyan,10);
  398.   Explode('    Mark the Largest Cell     ',14,36,blue,cyan,10);
  399. end;
  400.  
  401. Procedure Message2;
  402. begin
  403.   Explode('                             ',14,36,blue,cyan,10);
  404.   Explode('   Mark the Smallest Cell    ',14,36,blue,cyan,10);
  405. end;
  406.  
  407. Procedure Message3;
  408. begin
  409.   Explode('                             ',14,36,blue,cyan,10);
  410.   Explode('Mark the Brightest Clear Cell',14,36,blue,cyan,10);
  411. end;
  412.  
  413. Procedure Message4;
  414. begin
  415.   Explode('                             ',14,36,blue,cyan,10);
  416.   Explode(' Mark the Darkest Clear Cell ',14,36,blue,cyan,10);
  417. end;
  418.  
  419. Procedure Message6;
  420. begin
  421.   Explode('                             ',14,36,blue,cyan,10);
  422.   Explode(' Please add cell of interest ',14,36,blue,cyan,10);
  423. end;
  424.  
  425. Procedure Message7;
  426. begin
  427.   Explode('                             ',14,36,blue,cyan,10);
  428.   Explode('   check nucleolus shading   ',14,36,blue,cyan,10);
  429. end;
  430.  
  431. Procedure Message8;
  432. begin
  433.   Explode('                             ',14,36,blue,cyan,10);
  434.   Explode('1 if overshded,2 if undershad',14,36,blue,cyan,10);
  435. end;
  436.  
  437. Function GetOption(Ydig : integer):word;
  438. begin
  439.   If Ydig < 85 then
  440.     GetOption := 1
  441.   else if Ydig < 170 then
  442.     GetOption := 2
  443.   else if Ydig < 255 then
  444.     GetOption := 3
  445.   else if Ydig < 340 then
  446.     GetOption := 4
  447.   else if Ydig < 425 then
  448.     GetOption := 5
  449.   else
  450.     GetOption := 6;
  451. end;{end GetOption}
  452. {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  453.  
  454.  Function ChooseMenu(MenuData,x,y:byte):byte;
  455.  Var Choice,
  456.      Last   : byte;
  457.      Mdata  : Mtype;
  458.      colorx : byte;
  459.      colorf : byte;
  460.  Begin
  461.  
  462.    Choice := 3;
  463.    Last := 4;
  464.  
  465.    If MenuData = 0 then
  466.    begin
  467.      colorx := blue;
  468.      colorf := lightred;
  469.      Mdata := Menux;
  470.    end
  471.    else if Menudata = 1 then
  472.    begin
  473.      colorx := blue;
  474.      colorf := lightred;
  475.      Mdata := Menu1;
  476.    end
  477.    else if Menudata = 2 then
  478.    begin
  479.      colorx := cyan;
  480.      colorf := blue;
  481.      Mdata := Menu2;
  482.    end;
  483.  
  484.  
  485.    Repeat
  486.  
  487.     repeat
  488.      If Choice <> Last then
  489.       begin
  490.        Writetopage(mData[choice],attr(lightgreen,colorx),0,y+choice,x);
  491.        Writetopage(mData[last],attr(colorf,colorx),0,y+last,x);
  492.        Last := Choice;
  493.      end;
  494.      butdig := 0;
  495.      DigitLocate(xdig,ydig,butdig,errdig);
  496.      Choice := GetOption(Ydig);
  497.     until (butdig <> 0);
  498.  
  499.    Until ((Butdig = 1) or (ButDig = 2));
  500.  
  501.    ChooseMenu := Last;
  502.  
  503.  end;
  504.  
  505.  
  506.  
  507. Procedure ZapMWindow;
  508. begin
  509.   zapwindow;
  510. end;
  511.  
  512. Function Askwindow:boolean;
  513. Var ch : char;
  514.     done : boolean;
  515.  
  516. begin
  517.     zoomeffect := true;
  518.     blinkeffect := false;
  519.     zoomdelay := 20;
  520.     shadoweffect := right;
  521.     borderstyle := mixed;
  522.     scanpage;
  523.     createwindow(14,37,6,35,lightgray,magenta,green,black);
  524.     Explode('Is this acceptable?  (y/n)',16,42,lightgray,magenta,10);
  525.     done := FALSE;
  526.     Repeat
  527.       ch := readkey;
  528.       If (ch = 'y') or (ch = 'Y') then
  529.         begin
  530.           Done := TRUE;
  531.           AskWindow := TRUE;
  532.         end
  533.       else if (ch = 'n') or (ch = 'N') then
  534.         begin
  535.           Done := TRUE;
  536.           Askwindow := FALSE;
  537.         end;
  538.     Until Done;
  539.     Zapwindow;
  540. end;
  541.  
  542. Function Askwindow2:boolean;
  543. Var ch : char;
  544.     done : boolean;
  545.  
  546. begin
  547.     zoomeffect := true;
  548.     blinkeffect := false;
  549.     zoomdelay := 20;
  550.     shadoweffect := right;
  551.     borderstyle := mixed;
  552.     scanpage;
  553.     createwindow(14,37,6,35,lightgray,magenta,green,black);
  554.     Explode('Want to add an area?  (y/n)',16,42,lightgray,magenta,10);
  555.     done := FALSE;
  556.     Repeat
  557.       ch := readkey;
  558.       If (ch = 'y') or (ch = 'Y') then
  559.         begin
  560.           Done := TRUE;
  561.           AskWindow2 := TRUE;
  562.         end
  563.       else if (ch = 'n') or (ch = 'N') then
  564.         begin
  565.           Done := TRUE;
  566.           Askwindow2 := FALSE;
  567.         end;
  568.     Until Done;
  569.     Zapwindow;
  570. end;
  571.  
  572.  
  573. procedure HistogramStretch(Var hx,lx: byte);
  574. { ++++++++MOD 6/29/88 for AI++++++++++++++++++++++++++++++++++++++ }
  575.   var i,x,y,yy : integer;
  576.  
  577.   begin
  578.     setnocursor;
  579.     StretchLow := 0;
  580.     StretchHigh := 255;
  581.       MakeWindow1;
  582.       Gotoxy(34,11);
  583.       Writeln('Please Wait');
  584.       if ((hx = 255) and (lx = 0)) then
  585.         FindLowHigh(Stretchlow,StretchHigh)
  586.       else
  587.       begin
  588.         stretchlow := lx;
  589.         stretchhigh := hx;
  590.       end;
  591.       Beep;
  592.       UnMakeWindow1;
  593.  
  594.     MakeScreenWindow;
  595.       DrawHistogram(GLHistogram);
  596.       SetThresholds;
  597.       textbackground(black);
  598.  
  599.     UnMakeScreenWindow;
  600.     repeat
  601.         DigitLocate(XDig,YDig,ButDig,ErrDig)
  602.       until (ButDig = 0);
  603.   end;
  604.  
  605. Procedure fixit;
  606. begin
  607.   stretchlow := 0;
  608.   stretchhigh := 255;
  609.   stretchlut;
  610. end;
  611.  
  612. Procedure HistogramEqual;
  613. {+++++++++++++++++++++++++}
  614. Begin
  615.  
  616.   MakeWindow1;
  617.   Gotoxy(34,11);
  618.   Writeln('Please Wait');
  619.   FindLowHigh(Stretchlow,StretchHigh);
  620.   Beep;
  621.   StretchLUT;
  622.   UnMakeWindow1;
  623.  
  624. end;{end procedure HistogramEqual}
  625.  
  626.  
  627.  
  628.  
  629. End.
  630.